{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.FontPic.Parser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser for /properties/ files which are patterned after AFM
-- files.
--
--------------------------------------------------------------------------------

module Wumpus.FontPic.Parser
  ( 

    parseFaceSpec
  , faceSpec

  ) where


import Wumpus.FontPic.Datatypes

import qualified Text.LexemeParser as P

import Text.Parsec
import Text.Parsec.String

import Control.Applicative hiding ( many )
import qualified Data.Map as M

-- AFM files are whitespace significant - newline is a separator.


parseFaceSpec :: FilePath -> IO (Either ParseError FaceSpec)
parseFaceSpec = parseFromFile faceSpec

-- | @propsline@ expects a line end, EOF will cause a parse 
-- error...
-- 
propsline       :: String -> Parser a -> Parser a
propsline name p = symbol name *> p <* newline

props1          :: String -> Parser a -> Parser a
props1 name p   = symbol name *> p <* semi

faceSpec        :: Parser FaceSpec
faceSpec        = between start end faceSpec1
  where
    start       = symbol "StartFontProps 1.0" *> newline
    end         = symbol "EndFontProps"

faceSpec1       :: Parser FaceSpec
faceSpec1       = FaceSpec <$> fontName         <*> familyName
                           <*> styleName        <*> fontBBox
                           <*> unitsPerEm       <*> ascender
                           <*> descender        <*> height
                           <*> charMetrics      <*> charPaths


fontName        :: Parser String
fontName        = propsline "FontName" (many $ noneOf "\n")

familyName      :: Parser String
familyName      = propsline "FamilyName" (many $ noneOf "\n")
 
styleName       :: Parser String
styleName       = propsline "StyleName" (many $ noneOf "\n")

fontBBox        :: Parser (Int,Int,Int,Int)
fontBBox        = propsline "FontBBox" p
  where
    p = (,,,) <$> int <*> int <*> int <*> int

unitsPerEm      :: Parser Int
unitsPerEm      = propsline "UnitsPerEM" int

ascender        :: Parser Int
ascender        = propsline "Ascender" int

descender       :: Parser Int
descender       = propsline "Descender" int

height          :: Parser Int
height          = propsline "Height" int

charMetrics     :: Parser (M.Map Char CharSpec)
charMetrics     = 
    between start end (M.fromList . map fn <$> many charSpec)
  where
    start       = symbol "StartCharMetrics" *> newline
    end         = symbol "EndCharMetrics"   *> newline
    fn cs       = (char_id cs , cs)

charPaths       :: Parser (M.Map Char [Outline])
charPaths       = 
    between start end (M.fromList <$> outlines)
  where
    start       = symbol "StartCharPaths" *> newline
    end         = symbol "EndCharPaths"   *> newline




-- | A char can be called \' \' (space)...
--
charName        :: Parser Char
charName        = char 'N' *> char ' ' *> anyChar <* semi

charSpec        :: Parser CharSpec
charSpec        = CharSpec <$> charName <*> pwidth <*> pheight <*> (padvance <* newline)
  where
    pwidth      = props1 "W" int
    pheight     = props1 "H" int
    padvance    = (,) <$> props1 "AX" int <*> props1 "AY" int

outlines        :: Parser [(Char,[Outline])]
outlines        = sepEndBy outline newline

outline         :: Parser (Char,[Outline])
outline         = (,) <$> charName <*> sepEndBy (oneOf "LCM" >>= step) semi
  where
    step 'L'    = Lineto <$> (whiteSpace *> int) <*> int
    step 'M'    = Moveto <$> (whiteSpace *> int) <*> int
    step 'C'    = optionMaybe (char 'N') >>= maybe bezier (const conic)
    step _      = fail "outline - borked"
    bezier      = Curveto <$> (whiteSpace *> int) <*> int 
                        <*> int <*> int <*> int <*> int
    conic       = Conicto <$> (whiteSpace *> int) <*> int <*> int <*> int

--------------------------------------------------------------------------------
-- lexical

lx :: P.LexerSimple
lx = P.arbCharLexemeParser [ ' ', '\t' ]

-- newline         :: Parser ()
-- newline         = char '\n' >> return ()

-- lexeme          :: Parser a -> Parser a
-- lexeme p        = P.lexeme lx p  

whiteSpace      :: Parser ()
whiteSpace      = P.whiteSpace lx

symbol          :: String -> Parser String
symbol          = P.symbol lx

int             :: Parser Int
int             = P.int lx 

semi            :: Parser String
semi            = P.semi lx
